perm filename DRAWIT.F4[SAT,LCS] blob sn#502488 filedate 1981-07-22 generic text, type T, neo UTF8
C******* DRAWIT, LIST ************
	SUBROUTINE DRAWIT
	COMMON /ED/K,NEXT,NN,NX,NY,J
	COMMON /RZ/RSZ,RJB,CENTR  /RC/MCLEF(400),IST(1)
	COMMON/ZN/SCLEF(2,400)  /LL/LL  
	1 /JJJ/JJJ
CIRC	1 /DPY/NDP,IOV  
	DIMENSION ITEM(20)
	EQUIVALENCE(MM,SCLEF(1,1))
	DATA RN/15./,REL/-1.0/
C  INITIALIZED TO ABSOLUTE VECTORS.  BUT CHANGE TO RELATIVE WILL BE STICKY.
C  DISPLAYS OLD ITEM WITHOUT FILLER
	REL=-1
CC	JC=0
	KE=-1
	JCL=0
	RJ=1
	IF(MM.EQ.0)GO TO 20
	J=MM
	JX=-1
	JCL=MM
	NX=SCLEF(1,MM)
	NY=SCLEF(2,MM)
	GO TO 120
20	J=1
	JZ=J
2	NX=RJB*RSZ
	NY=CENTR*RSZ
121	JX=0
120	NZ=-1
	JC=1
	RL=NX
	RM=NY
C  L AND M ARE USED AS CONSTANTS WHEN RESETTING CURSOR
83	S=0
	CALL SETCUR(NX,NY,0)
4	IF(S)GO TO 81
CJ  NO MORE LIGHT PEN SELECTION.	IF(K.EQ.'E')GO TO 700
	IF(K.EQ.'E')GO TO 79
C  BYPASS FOR EDITING.
CIRC	CALL CURSOR(NX,NY)
C	CALL SETCUR(NX,NY,0)
	CALL DPYOUT(1)
45	FORMAT(' SET POINT ',$)
30	TYPE 45
	ACCEPT 144,K,ZK,KK
	CALL LO2UP(K)
	CALL LO2UP(ZK)
	CALL LO2UP(KK)
	IF(ZK.NE.'I'.OR.K.NE.'L')GO TO 33
C TYPE 'LI' TO LIST ALL VECTORS
	MCLEF(1)=J
	CALL LIST(0)
	GO TO 30
37	FORMAT(I4,') X,Y,Z= ',3I5)
33	IF(ZK.NE.'E')GO TO 344
	REL=0
C  TYPE 'REL' FOR RELATIVE VECTORS, 'A'=ABSOLUTE
	TYPE 31
	GO TO 30
31	FORMAT(' ***** RELATIVE VECTORS *****')
32	FORMAT(' ***** ABSOLUTE VECTORS *****')
344	IF(K.NE.'A')GO TO 244
	REL=-1
	TYPE 32
	GO TO 30
144	FORMAT(3A1)
244	IF(ZK.NE.'M')GO TO 444
C  TYPE SM TO SMOOTH, SMX=ERASE STRAIGHT LINES TEMPORARILY.
	MCLEF(1)=J
	CALL SMOOTH(KK)
	GO TO 4
444	IF(ZK.NE.'X')GO TO 445
	MCLEF(2)=MCLEF(2)+200000000
	K='X'
	GO TO 3
445	IF(ZK.EQ.'I')GO TO 447
C  TYPE 'CI' TO GENERATE CIRCLES AND ARCS
446	REREAD 1,K,ZK,XK
	CALL LO2UP(K)
	IF(K.LT.'-'.OR.K.GT.'9')GO TO 40
C SKIP NON-NUMBERS
	REREAD 11,RJ,RK,XK
	JMPR=0
	IF(XK.EQ.1)K='J'
C  TYPE 3RD NUM=1 FOR JUMPS
	IF(XK.EQ.2)K='F'
C  IF 3RD NUM=2 -- BEGIN FILL SECTION
41	QJ=RJ
	QK=RK
	IF(REL.LT.0)GO TO 141
241	X=X+QJ*RSZ
	Y=Y+QK*RSZ
	NX=X
	NY=Y
	GO TO 48
141	NX=GTPT(RJ,RJB)
	NY=GTPT(RK,CENTR)
	X=NX
	Y=NY
	GO TO 481
40	KK=ZK
C B=BACKUP, J=JUMP, CR=SET POINT, X=EXIT, LRUD-N
C  F=FILL IT, H=GO TO HOME-NUM, N=GO TO NEXT(AFTER AN 'H')
C  Z=ZERO IN ON NEARBY POINT, P=GO TO PREVIOUS, C=CLOSE THE AREA
C  D=EXTEND DRAWING,  F=START FILLER OUTLINE, SM=SMOOTH IT
C  TYPE 'FX' TO FILL ORIGINAL OUTLINE AND EXIT.
C  L,R,U,D + NUM  MOVES LAST POINT ENTERED.
	IF(ZK.NE.0)NZ=-1
C  WILL STAY IN "Z" MODE UNLESS NUMBER APPEARS.
	JMPR=0
	JCX=2
C  JCX IS FOR "ZEROING-IN" SECTION AND EDIT SECTION
C  FOR SHIFTS OF "JUMPS"
	IF(K.EQ.'B')GO TO 22
	IF(K.EQ.'C')GO TO 51
	IF(K.EQ.'X')GO TO 3
	IF(K.EQ.' ')GO TO 47
	IF(K.EQ.'J')GO TO 47
	IF(K.EQ.'Z')GO TO 47
	IF(K.EQ.'S')GO TO 79
	IF(K.EQ.'F')GO TO 47
	IF(K.NE.'H')GO TO 7
52	IF(KK.LE.1)KK=2
	X=SCLEF(1,KK)
	Y=SCLEF(2,KK)
	NEXT=KK+1
	IF(KE)GO TO 48
	RX=X
	RY=Y
58	IF(NEXT.GT.J+1)GO TO 83
	NN=JA-1
	CALL ITYP
	CALL EDTYP(K,X,Y,JJJ)
C  TYPE "A" OR ":" TO ALTER
C  TYPE "G"=GROUP CHANGE) TO MAKE RELATIVE CHANGE STICK
C  , THEN <CR>S. ANY OTHER LETTER TO ESCAPE
	IF(K.NE.'J')GO TO 573
C  J=JUMP TO NEXT 'JUMP'
	DO 574 K=NEXT,J
574	IF(MCLEF(K).GE.100000000)GO TO 575
575	X=K-NEXT+1
	GO TO 82
573  	IF(K.LT.'-')GO TO 1573
C  NEXT FOR NUMBERS ONLY -- FOR STEP AHEAD AND BACK
2573	REREAD 11,X
	GO TO 82
1573	IF(K.NE.'B')GO TO 570
	X=-X
	GO TO 82
570	IF(K.NE.' ')GO TO 1570
	IF(S)GO TO 81
1570	IF(K.EQ.'S')GO TO 82
C  S=STEP AHEAD(N) (-N  OR B GOES BACK)
	IF(K.EQ.'X')GO TO 3
	IF(K.NE.'LI')GO TO 1571
C TYPE 'LI' TO LIST ALL VECTORS
	CALL LIST(0)
	GO TO 58
CIRC1571	IF(K.NE.'M'.AND.K.NE.'R')GO TO 572
1571	IF(K.NE.'M'.AND.K.NE.'R'.AND.K.NE.'Q')GO TO 572
C  M OR R ALONE WILL MOVE LAST SET OF POINTS MOVED.  BUT BE CAREFUL!
C  Q REPEATS LAST COMMAND.
	LL=0
	IF(X+Y.EQ.0)GO TO 580
	IF(X.OR.Y.EQ.0)GO TO 577
C  "M  -N1, N2, N3" MOVES WHOLE BLOCKS (OR "M N1 0")
C   OR USE 'R' FOR 'M' TO ROTATE GROUP OF POINTS
C  TO SET ITEM # N2}0,  SETS ITEM # TO N3 IF N3}0.
	NY=Y-X+2
	NX=X+1
576	MX=NX
	MY=NY
580	CALL SHIFT(MCLEF(MX),MY,K)
C  TO MOVE SEGS MX THROUGH MY.
CIRC	CALL DPYCLR
	CALL HYDPOG(1)
C	CALL POG1
	CALL RDRAW(1,2,MCLEF(1),MCLEF)
CIRC	CALL RDRAW(2,MCLEF(1),MCLEF)
CIRC	CALL DPYOUT(NDP)
C	CALL DPYOUT(1)
	GO TO 58

577	NX=ABS(X)
	IF(Y.NE.0)GO TO 578
	CALL UNPACK(NX,NY,LL,ITEM(NX))
	GO TO 576
578	NY=ABS(Y)
	IF(JJJ.NE.0)GO TO 579
	IK=IK+1
	TYPE 46,IK
	JJJ=IK
	IF(JJJ.GT.10)GO TO 58
579	LL=0
	NY=NY-NX+2
	NX=NX+1
	JB=NX
	CALL REPACK(JB,NY,LL,ITEM(JJJ))
	GO TO 576

572	MCLEF(1)=J
	IF(K.EQ.'F')GO TO 470
C  TAKE OUT OTHER 'F'S IN DREDIT*****
571	CALL DREDIT
59	X=RX
	Y=RY
	KE=-1
	NX=0
	NY=0
	GO TO 170
C  THIS WRECKS "CLOSE"
470	MCLEF(NEXT-1)=MCLEF(NEXT-1)+200000000
	K='X'
	GO TO 34
47	IF(REL.EQ.0)GO TO 22
C  IF IN "REL" MODE TYPE "O" BEFORE USING LTPEN
	CALL RDCUR(NX,NY)
C THIS FOR STANFORD ONLY
	X=NX
	Y=NY
	IF((K.NE.'Z'.AND.NZ).OR.K.EQ.'J'.OR.K.EQ.'F')GO TO 48
	NZ=0
	DO 54 K=JCX,JCL
      IF(ABS(SCLEF(1,K)-X).GT.RN.OR.ABS(SCLEF(2,K)-Y).GT.RN)
	1 GO TO 54
	KK=K
	GO TO 52
54	CONTINUE
	IF(KE)GO TO 48
C  KE=-1  = DRAW MODE (NOT EDIT)
	TYPE 154
	GO TO 4
154	FORMAT(' NO POINT FOUND ')
C  ABOVE FOR INITIAL MOVEMENT OF CURSOR
51	DO 151 K=J,1,-1
	IF(MCLEF(K).LT.100000000)GO TO 151
C FIND LAST JUMP TO CLOSE THE AREA
	RX=SCLEF(1,K)
	RY=SCLEF(2,K)
	GO TO 251
151	CONTINUE
251	X=RX
	Y=RY
48	RJ=STPT(X,RJB)
	RK=STPT(Y,CENTR)
481	SK=RK
	J=J+1
551	SJ=RJ
C  DO I NEED RJ,RK ANYWHERE??  YES - AT REPACK
451	LL=0
	IF(K.EQ.'J')LL=100000000
C  J=JUMP
	IF(K.NE.'F')GO TO 452
	K='J'
253	LL=200000000
452	IJ=RJ
	IK=RK
	JCL=J
	CALL REPACK(IJ,IK,LL,MCLEF(J))
	IF(MCLEF(J).NE.MCLEF(J-1).OR.J.EQ.2)GO TO 60
61	J=J-1
	GO TO 4
60	SCLEF(1,J)=X
	SCLEF(2,J)=Y
50	X=GTPT(SJ,RJB)
	Y=GTPT(SK,CENTR)
	NX=X
	NY=Y
	IF(K.EQ.'B')GO TO 5
	IF(K.EQ.'J'.OR.JMPR.OR.JX.EQ.0)GO TO 6
CIRC	CALL VECT(IOV,NX,NY,0)
	CALL AVECT(NX,NY)
	GO TO 5
CIRC6	CALL VECT(IOV,NX,NY,1)
6	CALL AIVECT(NX,NY)
	JX=-1
	JMPR=-1
C  KZ IS FOR "CLOSE IT"
	NZ=-1
	RX=X
	RY=Y
5	L=J-1
	TYPE 46,L,SJ,SK

170	CALL SETCUR(NX,NY,JC)
	GO TO 4
CIRC170	GO TO 4
74	FORMAT(' S(TEP) OR L(IGHT PEN)? ',$)
7	IF(K.NE.'E')GO TO 71
C  E=EDIT 
71	IF(ZK.EQ.0)ZK=1
	IF(K.EQ.'L'.OR.K.EQ.'D')ZK=-ZK
	IF(K.EQ.'L'.OR.K.EQ.'R')GO TO 77
	SK=ZK+SK
	Y=GTPT(SK,CENTR)
	GO TO 78
77	SJ=ZK+SJ
	X=GTPT(SJ,RJB)
CIRC78	CALL DELVEC(J,J)
78	CALL BUP
C  DELETE THE LAST VECTOR FROM THE DPY BUFFER.
	J=J-1
C  DECREMENT THE VECTOR COUNTER
	GO TO 48
79	S=-1
	JA=ZK-1
84	IF(JA.LT.2)JA=1
81	IF(K.NE.'D')JA=JA+1
	IF(JA.GT.J)JA=J
	X=SCLEF(1,JA)
	Y=SCLEF(2,JA)
	NX=X
	NY=Y
	NEXT=JA+1
CIRC	CALL CURSOR(NX,NY)
	CALL SETCUR(NX,NY,0)
	GO TO 58
82	IF(X.EQ.0)X=-1
	JA=JA-1+X
	GO TO 84
22	IF(J.EQ.JZ)GO TO 4
C  CAN'T BACKUP PAST 1 OR 'F'

CIRC	CALL DELVEC(J,J)
	CALL BUP
C DELETE LAST VECTOR FROM DPY BUFFER.
	J=J-1
C  J IS VECTOR COUNT
122	CALL UNPACK(IJ,IK,LL,MCLEF(J))
	SJ=IJ
	SK=IK
	IF(K.EQ.'B')GO TO 50
	RJ=RJ+QJ
	RK=RK+QK
	GO TO 241
3	MCLEF(1)=J
	IF(MCLEF(2).LT.100000000)MCLEF(2)=MCLEF(2)+100000000
34	CALL CLRCUR
	IF(K.NE.'X')GO TO 120
	RETURN
1	FORMAT(A1,2F)
11	FORMAT(3F)
46	FORMAT(I3,'.)',2F6.0/)
447	JOLD=J
3447	TYPE 147
147	FORMAT(' TYPE RADIUS 1 AND RADIUS 2  '$)
	ACCEPT 1,K
	IF(K.NE.'B')GO TO 5447
2447	J=JOLD
	GO TO 5
5447	REREAD 11,RAD,RADX
C PUT IN LIGHT PEN FEATURE HERE.
	IF(RADX.EQ.0)RADX=RAD
C SAVE J FOR RETRY
4447	TYPE 247
247	FORMAT(' DEGREES OF 1ST AND LAST POINT (<CR>=0,360)  '$)
	ACCEPT 1,K
	IF(K.EQ.'B')GO TO 3447
	REREAD 11,D1,D2
	IF(D1.EQ.0.AND.D2.EQ.0)D2=360
	TYPE 347
347	FORMAT(' TYPE NUMBER OF VECTORS (<CR>=36)  '$)
	ACCEPT 1,K
	IF(K.EQ.'B')GO TO 4447
	REREAD 11,DD
	IF(DD.EQ.0)DD=36
	RADX=(RADX-RAD)/DD
	JD1=D1
	JD2=D2
	DD=(D2-D1)/DD
	XX=SJ-SIND(D1)*RAD
C GET OFFSET FOR X AND Y BASED ON RADIUS AND 1ST POINT IN DEGREES
	YY=SK-COSD(D1)*RAD
C X AND Y WERE LAST POINTS SET
	JST=IST(2)
C SAVE DPY POINTER IN CASE CURVE IS REJECTED
CC	DIMENSION JCIR(2,360)
847	JJ=0
C	DO 547 K=JD1,JD2,KK
C947	JJ=JJ+1
947	J=J+1
	D1=D1+DD
	A=D1
	IF(A.GT.360.)A=A-360.
	XA=SIND(A)*RAD+XX
	Y=.5
	IF(XA)Y=-Y
	NX=XA+Y
	XA=NX
C FOR ROUND-OFF
	X=GTPT(XA,RJB)
	NX=X
	XB=COSD(A)*RAD+YY
	A=.5
	IF(Y)A=-A
	NY=XB+A
	XB=NY
	Y=GTPT(XB,CENTR)
	NY=Y
	RAD=RAD+RADX
	CALL AVECT(NX,NY)
C	JCIR(1,JJ)=XA
C	JCIR(2,JJ)=XB
	SCLEF(1,J)=XA
	SCLEF(2,J)=XB
C547	TYPE 46,JJ,XA,XB
CC	D1=D1+DD
	IF(DD.LT.0)GO TO 1447
1147	IF(D1.LT.D2)GO TO 947
	GO TO 1247
1447	IF(D1.GE.D2)GO TO 947
1247	CALL DPYOUT(1)
	TYPE 647
647	FORMAT(' ALL O.K.?  '$)
	ACCEPT 1,K
	IF(K.NE.'N')GO TO 747
	IST(2)=JST
	CALL ACCPOG(1)
	CALL DPYOUT(1)
	J=JOLD
	GO TO 3447
747	CALL SETCUR(NX,NY)
	LL=0
C	DO 1547 K=1,JJ
	DO 1547 K=JOLD+1,J
C	J=J+1
C NOW PUT THE CURVE INTO THE ARRAY
	MX=SCLEF(1,K)
	MY=SCLEF(2,K)
1547	CALL REPACK(MX,MY,0,MCLEF(K))
C1547	CALL REPACK(JCIR(1,K),JCIR(2,K),LL,MCLEF(J))
	JCL=J
	SJ=SCLEF(1,J)
	SK=SCLEF(2,J)
C	GO TO 4
	GO TO 5
	END

	SUBROUTINE LIST(N)
	COMMON /RC/MCLEF(1)
CC	COMMON /ED/I,NEXT,NN,NX,NY,J /RC/MCLEF(1)
CIRC	IF(N.NE.0)OPEN(UNIT=1,FILE=N)
	IF(N.NE.0)CALL OFILE(1,N)
C NEXT WILL LIST ALL VECTORS
	DO 35 K=2,MCLEF(1)
C J ALWAYS POINTS TO LAST VECTOR IN MCLEF ARRAY. (MCLEF(1)=WDCOUNT)
	CALL UNPACK(JX,JY,JZ,MCLEF(K))
	JK=K-1
	JZ=JZ/100000000
	IF(N.NE.0)WRITE(1,2)JK,JX,JY,JZ
35	IF(N.EQ.0)TYPE 37,JK,JX,JY,JZ
	IF(N.EQ.0)RETURN
CIRC	CLOSE(UNIT=1)
	END FILE 1
2	FORMAT(4I5)
37	FORMAT(I4,') X,Y,Z= ',3I5)
	END